{-# LANGUAGE PatternGuards              #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Orca.Csound.Utils
-- Copyright   :  (c) Stephen Tetley 2013
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Helper functions.
--
--------------------------------------------------------------------------------

module Orca.Csound.Utils
  (
    
    truncatedDouble
  , commaSep
  , blank_doc
  , padTextR
  , tupled

  -- * Hughes lists
  , H  
  , emptyH
  , wrapH
  , consH
  , snocH
  , appendH
  , toListH
    
  ) where


import Text.PrettyPrint.HughesPJ            -- pacakge: pretty

import Numeric ( showFFloat )





-- | Truncate the printed decimal representation of a Double.
-- This may be prefered to 'showFFloat' from Numeric as it 
-- produces shorter representations when the value has trailing
-- zeros.
-- 
-- 0.000000000 becomes 0.0 rather than however many digits are 
-- specified.
--  
truncatedDouble :: Double -> Doc
truncatedDouble d 
    | abs d < 0.0001  = text $ "0.0"
    | d < 0.0         = text $ '-' :  showFFloat_ (abs tx)
    | otherwise       = text $ showFFloat_ tx
  where
    tx :: Double
    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0

roundi :: RealFrac a => a -> Integer
roundi = round

showFFloat_ :: RealFloat a => a -> String
showFFloat_ = ($ "") . showFFloat Nothing


commaSep :: [Doc] -> Doc
commaSep []     = empty
commaSep [x]    = x 
commaSep (x:xs) = x <> comma <+> commaSep xs


-- | blank_doc - can be used to make blank lines whereas @empty@
-- is absorbed.
--
blank_doc :: Doc
blank_doc = zeroWidthText ""


padTextR :: Int -> String -> Doc
padTextR i ss | len <- length ss
              , len < i           = text ss <> text (replicate (i -len) ' ')
padTextR _ ss                     = text ss



tupled :: [Doc] -> Doc
tupled ds = parens $ hcat $ punctuate comma ds


--------------------------------------------------------------------------------
-- Hughes list

type H a = [a] -> [a]

emptyH :: H a
emptyH = id

wrapH :: a -> H a
wrapH a = (a:)

consH :: a -> H a -> H a
consH a h = (a:) . h

snocH :: H a -> a -> H a
snocH h a = h . (a:)

appendH :: H a -> H a-> H a
appendH = (.)

toListH :: H a -> [a]
toListH h = h []